home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1997 / MacHack 1997.toast / Presentations / Presentations ’93 / Voice Toolkit / Voice Guessing < prev    next >
Encoding:
Text File  |  1992-11-25  |  1.8 KB  |  67 lines  |  [TEXT/CCL2]
  1.  
  2. (in-package "VOICE-TOOLKIT")
  3.  
  4.  
  5. (defun mappend (fn lst)
  6.   (apply #'append (mapcar fn lst)))
  7.  
  8.  
  9. (defun match-words-to-items (words)
  10.   (if (null (rest words))
  11.     (gethash (first words) *wordtable*)
  12.     (intersection (gethash (first words) *wordtable*)
  13.                   (match-words-to-items (rest words)))))
  14.  
  15.  
  16. (defun guess-fixes ()
  17.   (setf *fixes* 
  18.         (sort (mappend 
  19.                #'(lambda (word)
  20.                    (mapcar #'(lambda (fx)
  21.                                (list word fx))
  22.                            (match-words-to-items 
  23.                             (remove word *wordlist*))))
  24.                *wordlist*)
  25.               #'compare-fix-weight)))
  26.  
  27.  
  28. (defun compare-fix-weight (f1 f2)
  29.   "ordering function for sorting fixes"
  30.   (> (fix-weight f1) (fix-weight f2)))
  31.  
  32.  
  33. (defun fix-weight (fix)
  34.   (sum-fix-weight (get-twins (first fix))
  35.                   (set-diff (string-to-wordlist 
  36.                              (text (second fix))) *wordlist*)))
  37.  
  38.  
  39. (defun sum-fix-weight (twins words &optional (count 0) (prob 0))
  40.   (cond ((null twins)
  41.          (if (< count 1) 0 (/ prob count)))
  42.         ((member (twin-word (first twins)) words :test #'equal)
  43.          (sum-fix-weight (rest twins) 
  44.                          words
  45.                          (+ count (twin-count (first twins)))
  46.                          (+ prob (twin-prob (first twins)))))
  47.         (t (sum-fix-weight (rest twins) words count prob))))
  48.   
  49.  
  50.  
  51. (defun fix-word ()
  52.   (first (first *fixes*)))
  53.  
  54.  
  55. (defun fix-item ()
  56.   (second (first *fixes*)))
  57.  
  58.  
  59. (defun record-fix ()
  60.   (let ((possible 
  61.          (set-diff (string-to-wordlist (text (fix-item)))
  62.                    *wordlist*)))
  63.     (mapcar #'(lambda (word)
  64.                 (hash-twin (fix-word)
  65.                            (make-twin word 1 (/ 1 (length possible)))))
  66.             possible)))
  67.